home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / heap.com / GRABHEAP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-03-11  |  2.3 KB  |  87 lines
  1. {*****************************************************************************
  2.  This unit lets a program take control of the standard operations for New,
  3.  GetMem, Dispose, FreeMem from the SYSTEM unit. USE it anywhere in a program's
  4.  USES list. You must call the routine CustomHeapControl in order to grab
  5.  control.
  6.  
  7.  For further information about this unit, refer to HEAP.DOC.
  8.  
  9.  Written 7/18/88, Kim Kokkonen, TurboPower Software.
  10.  Compuserve ID 72457,2131
  11.  Released to the public domain.
  12.  
  13.  Version 1.0
  14.    First release.
  15.  Version 5.0
  16.    For consistency with 5.0 release of other heap utilities.
  17. *****************************************************************************}
  18.  
  19. {$R-,S-,B-,F-}
  20.  
  21. unit GrabHeap;
  22.  
  23. interface
  24.  
  25. procedure CustomHeapControl(GetPtr, FreePtr : Pointer);
  26.   {-Give control of GetMem, New, FreeMem, Dispose to specified procedures}
  27.  
  28. procedure SystemHeapControl;
  29.   {-Restore control to the system heap routines}
  30.  
  31.   {===============================================================}
  32.  
  33. implementation
  34.  
  35. type
  36.   Xfer = record
  37.            Instr : Byte;
  38.            Addr : Pointer;
  39.          end;
  40. var
  41.   P : ^Byte;
  42.   GetMemPtr : ^Xfer;
  43.   FreeMemPtr : ^Xfer;
  44.   GetSave : Xfer;
  45.   FreeSave : Xfer;
  46.  
  47.   procedure CustomHeapControl(GetPtr, FreePtr : Pointer);
  48.   var
  49.     X : Xfer;
  50.   begin
  51.     with X do begin
  52.       Instr := $EA;               {JMP FAR}
  53.       Addr := GetPtr;
  54.       GetMemPtr^ := X;
  55.       Addr := FreePtr;
  56.       FreeMemPtr^ := X;
  57.     end;
  58.   end;
  59.  
  60.   procedure SystemHeapControl;
  61.   begin
  62.     GetMemPtr^ := GetSave;
  63.     FreeMemPtr^ := FreeSave;
  64.   end;
  65.  
  66.   function FindFarProcCall : Pointer;
  67.     {-Return pointer to far procedure called just previously}
  68.   inline
  69.   ($E8/$00/$00/                   {  call next}
  70.    $5F/                           {next:  pop  di}
  71.    $0E/                           {  push cs}
  72.    $07/                           {  pop  es}
  73.    $83/$EF/$07/                   {  sub  di,7}
  74.    $26/$C4/$05/                   {  les  ax,es:[di]}
  75.    $8C/$C2);                      {  mov  dx,es}
  76.  
  77. begin
  78.   {Find GetMem and FreeMem in SYSTEM}
  79.   New(P);
  80.   GetMemPtr := FindFarProcCall;
  81.   Dispose(P);
  82.   FreeMemPtr := FindFarProcCall;
  83.   {Save the first 5 bytes of each routine, which will be overwritten}
  84.   GetSave := GetMemPtr^;
  85.   FreeSave := FreeMemPtr^;
  86. end.
  87.